home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / mwexpand < prev    next >
Text File  |  1993-09-08  |  18KB  |  553 lines
  1. ; Copyright 1992 William Clinger
  2. ;
  3. ; Permission to copy this software, in whole or in part, to use this
  4. ; software for any lawful purpose, and to redistribute this software
  5. ; is granted subject to the restriction that all copies made of this
  6. ; software must include this copyright notice in full.
  7. ;
  8. ; I also request that you send me a copy of any improvements that you
  9. ; make to this software so that they may be incorporated within it to
  10. ; the benefit of the Scheme community.
  11. ;
  12. ; The external entry points and kernel of the macro expander.
  13. ;
  14. ; Part of this code is snarfed from the Twobit macro expander.
  15.  
  16. (define mw:define-syntax-scope
  17.   (let ((flag 'letrec))
  18.     (lambda args
  19.       (cond ((null? args) flag)
  20.         ((not (null? (cdr args)))
  21.          (apply mw:warn
  22.             "Too many arguments passed to define-syntax-scope"
  23.             args))
  24.         ((memq (car args) '(letrec letrec* let*))
  25.          (set! flag (car args)))
  26.         (else (mw:warn "Unrecognized argument to define-syntax-scope"
  27.               (car args)))))))
  28.  
  29. (define mw:quit             ; assigned by macwork:expand
  30.   (lambda (v) v))
  31.  
  32. (define (macwork:expand def-or-exp)
  33.   (call-with-current-continuation
  34.    (lambda (k)
  35.      (set! mw:quit k)
  36.      (set! mw:renaming-counter 0)
  37.      (mw:desugar-definitions def-or-exp mw:global-syntax-environment))))
  38.  
  39. (define (macwork:eval form) (eval (macwork:expand form))) ;; added -KenD
  40.  
  41. (define (macwork:load file-path) ;; added -KenD
  42.     (call-with-input-file 
  43.      file-path
  44.      (lambda (in)
  45.        (let loop ( (form (read in)) )
  46.      (if (eof-object? form)
  47.          file-path  ;; done
  48.          (begin
  49.            (macwork:eval form)
  50.            (loop (read in)))
  51.  
  52. )))))
  53.  
  54. (define (mw:desugar-definitions exp env)
  55.   (letrec 
  56.     ((define-loop 
  57.        (lambda (exp rest first)
  58.      (cond ((and (pair? exp)
  59.              (eq? (mw:syntax-lookup env (car exp))
  60.               mw:denote-of-begin)
  61.              (pair? (cdr exp)))
  62.         (define-loop (cadr exp) (append (cddr exp) rest) first))
  63.            ((and (pair? exp)
  64.              (eq? (mw:syntax-lookup env (car exp))
  65.               mw:denote-of-define))
  66.         (let ((exp (desugar-define exp env)))
  67.           (cond ((and (null? first) (null? rest))
  68.              exp)
  69.             ((null? rest)
  70.              (cons mw:begin1 (reverse (cons exp first))))
  71.             (else (define-loop (car rest)
  72.                        (cdr rest)
  73.                        (cons exp first))))))
  74.            ((and (pair? exp)
  75.              (eq? (mw:syntax-lookup env (car exp))
  76.               mw:denote-of-define-syntax)
  77.              (null? first))
  78.         (define-syntax-loop exp rest))
  79.            ((and (null? first) (null? rest))
  80.         (mw:expand exp env))
  81.            ((null? rest)
  82.         (cons mw:begin1 (reverse (cons (mw:expand exp env) first))))
  83.            (else (cons mw:begin1
  84.                (append (reverse first)
  85.                    (map (lambda (exp) (mw:expand exp env))
  86.                     (cons exp rest))))))))
  87.      
  88.      (desugar-define
  89.       (lambda (exp env)
  90.     (cond 
  91.      ((null? (cdr exp)) (mw:error "Malformed definition" exp))
  92.      ; (define foo) syntax is transformed into (define foo (undefined)).
  93.      ((null? (cddr exp))
  94.       (let ((id (cadr exp)))
  95.         (redefinition id)
  96.         (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
  97.         (list mw:define1 id mw:undefined)))
  98.      ((pair? (cadr exp))
  99.       ; mw:lambda0 is an unforgeable lambda, needed here because the
  100.       ; lambda expression will undergo further expansion.
  101.       (desugar-define `(,mw:define1 ,(car (cadr exp))
  102.                      (,mw:lambda0 ,(cdr (cadr exp))
  103.                            ,@(cddr exp)))
  104.               env))
  105.      ((> (length exp) 3) (mw:error "Malformed definition" exp))
  106.      (else (let ((id (cadr exp)))
  107.          (redefinition id)
  108.          (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
  109.          `(,mw:define1 ,id ,(mw:expand (caddr exp) env)))))))
  110.      
  111.      (define-syntax-loop 
  112.        (lambda (exp rest)
  113.      (cond ((and (pair? exp)
  114.              (eq? (mw:syntax-lookup env (car exp))
  115.               mw:denote-of-begin)
  116.              (pair? (cdr exp)))
  117.         (define-syntax-loop (cadr exp) (append (cddr exp) rest)))
  118.            ((and (pair? exp)
  119.              (eq? (mw:syntax-lookup env (car exp))
  120.               mw:denote-of-define-syntax))
  121.         (if (pair? (cdr exp))
  122.             (redefinition (cadr exp)))
  123.         (if (null? rest)
  124.             (mw:define-syntax exp env)
  125.             (begin (mw:define-syntax exp env)
  126.                (define-syntax-loop (car rest) (cdr rest)))))
  127.            ((null? rest)
  128.         (mw:expand exp env))
  129.            (else (cons mw:begin1
  130.                (map (lambda (exp) (mw:expand exp env))
  131.                     (cons exp rest)))))))
  132.      
  133.      (redefinition
  134.       (lambda (id)
  135.     (if (symbol? id)
  136.         (if (not (mw:identifier?
  137.               (mw:syntax-lookup mw:global-syntax-environment id)))
  138.         (mw:warn "Redefining keyword" id))
  139.         (mw:error "Malformed variable or keyword" id)))))
  140.     
  141.     ; body of letrec
  142.     
  143.     (define-loop exp '() '())))
  144.  
  145. ; Given an expression and a syntactic environment,
  146. ; returns an expression in core Scheme.
  147.  
  148. (define (mw:expand exp env)
  149.   (if (not (pair? exp))
  150.       (mw:atom exp env)
  151.       (let ((keyword (mw:syntax-lookup env (car exp))))
  152.     (case (mw:denote-class keyword)
  153.       ((special)
  154.        (cond
  155.         ((eq? keyword mw:denote-of-quote)         (mw:quote exp))
  156.         ((eq? keyword mw:denote-of-lambda)        (mw:lambda exp env))
  157.         ((eq? keyword mw:denote-of-if)            (mw:if exp env))
  158.         ((eq? keyword mw:denote-of-set!)          (mw:set exp env))
  159.         ((eq? keyword mw:denote-of-begin)         (mw:begin exp env))
  160.         ((eq? keyword mw:denote-of-let-syntax)    (mw:let-syntax exp env))
  161.         ((eq? keyword mw:denote-of-letrec-syntax)
  162.          (mw:letrec-syntax exp env))
  163.         ; @@ let, let*, letrec, paint within quasiquotation -- kend
  164.         ((eq? keyword mw:denote-of-let)           (mw:let    exp env))
  165.         ((eq? keyword mw:denote-of-let*)          (mw:let*   exp env))
  166.         ((eq? keyword mw:denote-of-letrec)        (mw:letrec exp env))
  167.         ((eq? keyword mw:denote-of-quasiquote)    (mw:quasiquote exp env))
  168.         ((eq? keyword mw:denote-of-do)            (mw:do     exp env))
  169.         ((or (eq? keyword mw:denote-of-define)
  170.          (eq? keyword mw:denote-of-define-syntax))
  171.          ;; slight hack to allow expansion into defines -KenD
  172.          (if mw:in-define? 
  173.            (mw:error "Definition out of context" exp)
  174.            (begin
  175.          (set! mw:in-define? #t)
  176.          (let ( (result (mw:desugar-definitions exp env)) )
  177.            (set! mw:in-define? #f)
  178.            result))
  179.         ))
  180.         (else (mw:bug "Bug detected in mw:expand" exp env))))
  181.       ((macro) (mw:macro exp env))
  182.       ((identifier) (mw:application exp env))
  183.       (else (mw:bug "Bug detected in mw:expand" exp env))
  184.       ) )
  185. ) )
  186.  
  187. (define mw:in-define? #f)  ; should be fluid
  188.  
  189. (define (mw:atom exp env)
  190.   (cond ((not (symbol? exp))
  191.      ; Here exp ought to be a boolean, number, character, or string,
  192.      ; but I'll allow for non-standard extensions by passing exp
  193.      ; to the underlying Scheme system without further checking.
  194.      exp)
  195.     (else (let ((denotation (mw:syntax-lookup env exp)))
  196.         (case (mw:denote-class denotation)
  197.           ((special macro)
  198.            (mw:error "Syntactic keyword used as a variable" exp env))
  199.           ((identifier) (mw:identifier-name denotation))
  200.           (else (mw:bug "Bug detected by mw:atom" exp env)))))))
  201.  
  202. (define (mw:quote exp)
  203.   (if (= (mw:safe-length exp) 2)
  204.       (list mw:quote1 (mw:strip (cadr exp)))
  205.       (mw:error "Malformed quoted constant" exp)))
  206.  
  207. (define (mw:lambda exp env)
  208.   (if (> (mw:safe-length exp) 2)
  209.       (let* ((formals (cadr exp))
  210.          (alist (mw:rename-vars (mw:make-null-terminated formals)))
  211.          (env (mw:syntax-rename env alist))
  212.          (body (cddr exp)))
  213.     (list mw:lambda1
  214.           (mw:rename-formals formals alist)
  215.           (mw:body body env)))
  216.       (mw:error "Malformed lambda expression" exp)))
  217.  
  218. (define (mw:body body env)
  219.   (define (loop body env defs)
  220.     (if (null? body)
  221.     (mw:error "Empty body"))
  222.     (let ((exp (car body)))
  223.       (if (and (pair? exp)
  224.            (symbol? (car exp)))
  225.       (let ((denotation (mw:syntax-lookup env (car exp))))
  226.         (case (mw:denote-class denotation)
  227.           ((special)
  228.            (cond ((eq? denotation mw:denote-of-begin)
  229.               (loop (append (cdr exp) (cdr body)) env defs))
  230.              ((eq? denotation mw:denote-of-define)
  231.               (loop (cdr body) env (cons exp defs)))
  232.              (else (mw:finalize-body body env defs))))
  233.           ((macro)
  234.            (mw:transcribe exp
  235.                  env
  236.                  (lambda (exp env)
  237.                    (loop (cons exp (cdr body))
  238.                      env
  239.                      defs))))
  240.           ((identifier)
  241.            (mw:finalize-body body env defs))
  242.           (else (mw:bug "Bug detected in mw:body" body env))))
  243.       (mw:finalize-body body env defs))))
  244.   (loop body env '()))
  245.  
  246. (define (mw:finalize-body body env defs)
  247.   (if (null? defs)
  248.       (let ((body (map (lambda (exp) (mw:expand exp env))
  249.                body)))
  250.     (if (null? (cdr body))
  251.         (car body)
  252.         (cons mw:begin1 body)))
  253.       (let* ((alist (mw:rename-vars '(quote lambda set!)))
  254.          (env (mw:syntax-alias env alist mw:standard-syntax-environment))
  255.          (new-quote  (cdr (assq 'quote alist)))
  256.          (new-lambda (cdr (assq 'lambda alist)))
  257.          (new-set!   (cdr (assq 'set!   alist))))
  258.     (define (desugar-definition def)
  259.       (if (> (mw:safe-length def) 2)
  260.           (cond ((pair? (cadr def))
  261.              (desugar-definition
  262.               `(,(car def)
  263.             ,(car (cadr def))
  264.             (,new-lambda
  265.               ,(cdr (cadr def))
  266.               ,@(cddr def)))))
  267.             ((= (length def) 3)
  268.              (cdr def))
  269.             (else (mw:error "Malformed definition" def env)))
  270.           (mw:error "Malformed definition" def env)))
  271.     (mw:letrec
  272.      `(letrec ,(map desugar-definition (reverse defs)) ,@body)
  273.       env)))
  274.   )
  275.  
  276. (define (mw:if exp env)
  277.   (let ((n (mw:safe-length exp)))
  278.     (if (or (= n 3) (= n 4))
  279.     (cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp)))
  280.     (mw:error "Malformed if expression" exp env))))
  281.  
  282. (define (mw:set exp env)
  283.   (if (= (mw:safe-length exp) 3)
  284.       `(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env))
  285.       (mw:error "Malformed assignment" exp env)))
  286.  
  287. (define (mw:begin exp env)
  288.   (if (positive? (mw:safe-length exp))
  289.       `(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp)))
  290.       (mw:error "Malformed begin expression" exp env)))
  291.  
  292. (define (mw:application exp env)
  293.   (if (> (mw:safe-length exp) 0)
  294.       (map (lambda (exp) (mw:expand exp env))
  295.        exp)
  296.       (mw:error "Malformed application")))
  297.  
  298. ; I think the environment argument should always be global here.
  299.  
  300. (define (mw:define-syntax exp env)
  301.   (cond ((and (= (mw:safe-length exp) 3)
  302.           (symbol? (cadr exp)))
  303.      (mw:define-syntax1 (cadr exp)
  304.                (caddr exp)
  305.                env
  306.                (mw:define-syntax-scope)))
  307.     ((and (= (mw:safe-length exp) 4)
  308.           (symbol? (cadr exp))
  309.           (memq (caddr exp) '(letrec letrec* let*)))
  310.      (mw:define-syntax1 (cadr exp)
  311.                (cadddr exp)
  312.                env
  313.                (caddr exp)))
  314.     (else (mw:error "Malformed define-syntax" exp env))))
  315.  
  316. (define (mw:define-syntax1 keyword spec env scope)
  317.   (case scope
  318.     ((letrec)  (mw:define-syntax-letrec keyword spec env))
  319.     ((letrec*) (mw:define-syntax-letrec* keyword spec env))
  320.     ((let*)    (mw:define-syntax-let* keyword spec env))
  321.     (else      (mw:bug "Weird scope" scope)))
  322.   (list mw:quote1 keyword))
  323.  
  324. (define (mw:define-syntax-letrec keyword spec env)
  325.   (mw:syntax-bind-globally!
  326.    keyword
  327.    (mw:compile-transformer-spec spec env)))
  328.  
  329. (define (mw:define-syntax-letrec* keyword spec env)
  330.   (let* ((env (mw:syntax-extend (mw:syntax-copy env)
  331.                 (list keyword)
  332.                 '((fake denotation))))
  333.      (transformer (mw:compile-transformer-spec spec env)))
  334.     (mw:syntax-assign! env keyword transformer)
  335.     (mw:syntax-bind-globally! keyword transformer)))
  336.  
  337. (define (mw:define-syntax-let* keyword spec env)
  338.   (mw:syntax-bind-globally!
  339.    keyword
  340.    (mw:compile-transformer-spec spec (mw:syntax-copy env))))
  341.  
  342. (define (mw:let-syntax exp env)
  343.   (if (and (> (mw:safe-length exp) 2)
  344.        (comlist:every (lambda (binding)
  345.             (and (pair? binding)
  346.              (symbol? (car binding))
  347.              (pair? (cdr binding))
  348.              (null? (cddr binding))))
  349.             (cadr exp)))
  350.       (mw:body (cddr exp)
  351.           (mw:syntax-extend env
  352.                 (map car (cadr exp))
  353.                 (map (lambda (spec)
  354.                        (mw:compile-transformer-spec
  355.                     spec
  356.                     env))
  357.                      (map cadr (cadr exp)))))
  358.       (mw:error "Malformed let-syntax" exp env)))
  359.  
  360. (define (mw:letrec-syntax exp env)
  361.   (if (and (> (mw:safe-length exp) 2)
  362.        (comlist:every (lambda (binding)
  363.             (and (pair? binding)
  364.              (symbol? (car binding))
  365.              (pair? (cdr binding))
  366.              (null? (cddr binding))))
  367.             (cadr exp)))
  368.       (let ((env (mw:syntax-extend env
  369.                    (map car (cadr exp))
  370.                    (map (lambda (id)
  371.                       '(fake denotation))
  372.                     (cadr exp)))))
  373.     (for-each (lambda (id spec)
  374.             (mw:syntax-assign!
  375.              env
  376.              id
  377.              (mw:compile-transformer-spec spec env)))
  378.           (map car (cadr exp))
  379.           (map cadr (cadr exp)))
  380.     (mw:body (cddr exp) env))
  381.       (mw:error "Malformed let-syntax" exp env)))
  382.  
  383. (define (mw:macro exp env)
  384.   (mw:transcribe exp
  385.         env
  386.         (lambda (exp env)
  387.           (mw:expand exp env))))
  388.  
  389. ; To do:
  390. ; Clean up alist hacking et cetera.
  391.  
  392. ;;-----------------------------------------------------------------
  393. ;; The following was added to allow expansion without flattening 
  394. ;; LETs to LAMBDAs so that the origianl structure of the program 
  395. ;; is preserved by macro expansion.  I.e. so that usual.scm is not 
  396. ;; required. -- added KenD 
  397.  
  398. (define (mw:process-let-bindings alist binding-list env)  ;; helper proc
  399.   (map (lambda (bind)
  400.      (list (cdr (assq (car bind) alist)) ; renamed name
  401.            (mw:body (cdr bind) env)))     ; alpha renamed value expression
  402.        binding-list)
  403. )
  404.  
  405. (define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in
  406.   (if (and (pair? exp) (eq? (car exp) 'begin))
  407.     (cdr exp)
  408.     exp)
  409. )
  410.  
  411. ; LET
  412. (define (mw:let exp env)
  413.   (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp)))
  414.             #f 
  415.             (cadr exp)))  ; named let?
  416.       (binds (if name (caddr exp) (cadr exp)))
  417.       (body  (if name (cdddr exp) (cddr exp)))
  418.       (vars  (if (null? binds) #f (map car binds)))
  419.       (alist (if vars (mw:rename-vars vars) #f))
  420.       (newenv (if alist (mw:syntax-rename env alist) env))
  421.     )
  422.     (if name  ;; extend env with new name
  423.     (let ( (rename (mw:rename-vars (list name))) )
  424.       (set! alist (append rename alist))
  425.       (set! newenv (mw:syntax-rename newenv rename))
  426.     )   )
  427.     `(let
  428.      ,@(if name (list (cdr (assq name alist))) '())
  429.      ,(mw:process-let-bindings alist binds env)
  430.      ,(mw:body body newenv))
  431. ) )
  432.  
  433.  
  434. ; LETREC differs from LET in that the binding values are processed in the
  435. ; new rather than the original environment.
  436.  
  437. (define (mw:letrec exp env)
  438.   (let* ( (binds (cadr exp))
  439.       (body  (cddr exp))
  440.       (vars  (if (null? binds) #f (map car binds)))
  441.       (alist (if vars (mw:rename-vars vars) #f))
  442.       (newenv (if alist (mw:syntax-rename env alist) env))
  443.     )
  444.     `(letrec
  445.       ,(mw:process-let-bindings alist binds newenv)
  446.       ,(mw:body body newenv))
  447. ) )
  448.  
  449.  
  450. ; LET* adds to ENV for each new binding.
  451.  
  452. (define (mw:let* exp env)
  453.   (let ( (binds (cadr exp))
  454.      (body  (cddr exp))
  455.        )
  456.     (let bind-loop ( (bindings binds) (newbinds '()) (newenv env) )
  457.        (if (null? bindings)
  458.       `(let* ,(reverse newbinds) ,(mw:body body newenv))
  459.        (let* ( (bind (car bindings))
  460.            (var    (car bind)) 
  461.            (valexp (cdr bind))
  462.            (rename (mw:rename-vars (list var)))
  463.            (next-newenv (mw:syntax-rename newenv rename))
  464.          )
  465.          (bind-loop (cdr bindings) 
  466.             (cons (list (cdr (assq var rename))
  467.                     (mw:body valexp newenv))
  468.                   newbinds)
  469.             next-newenv))
  470. ) ) ) )
  471.  
  472.  
  473. ; DO
  474.  
  475. (define (mw:process-do-bindings var-init-steps alist oldenv newenv)  ;; helper proc
  476.   (map (lambda (vis)
  477.      (let ( (v (car vis))
  478.         (i (cadr vis))
  479.         (s (if (null? (cddr vis)) (car vis) (caddr vis))))
  480.        `( ,(cdr (assq v alist)) ; renamed name
  481.           ,(mw:body (list i) oldenv)     ; init in outer/old env
  482.           ,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env
  483.        var-init-steps)
  484. )
  485.  
  486. (define (mw:do exp env)
  487.   (let* ( (vis  (cadr exp))  ; (Var Init Step ...)
  488.       (ts   (caddr exp)) ; (Test Sequence ...)
  489.       (com  (cdddr exp)) ; (COMmand ...)
  490.       (vars (if (null? vis) #f (map car vis)))
  491.       (rename (if vars (mw:rename-vars vars) #f))
  492.       (newenv (if vars (mw:syntax-rename env rename) env))
  493.     )
  494.     `(do ,(if vars (mw:process-do-bindings vis rename env newenv) '())
  495.      ,(if  (null? ts)  '() (mw:strip-begin (mw:body (list ts) newenv)))
  496.      ,@(if (null? com) '() (list (mw:body com newenv))))
  497. ) )
  498.  
  499. ;
  500. ; Quasiquotation (backquote)           
  501. ;
  502. ; At level 0, unquoted forms are left painted (not mw:strip'ed).
  503. ; At higher levels, forms which are unquoted to level 0 are painted.
  504. ; This includes forms within quotes.  E.g.:
  505. ;   (lambda (a) 
  506. ;     (quasiquote 
  507. ;       (a (unquote a) b (quasiquote (a (unquote (unquote a)) b)))))
  508. ;or equivalently:
  509. ;  (lambda (a) `(a ,a b `(a ,,a b)))
  510. ;=>
  511. ;  (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b)))
  512.  
  513. (define (mw:quasiquote exp env)
  514.  
  515.   (define (mw:atom exp env)
  516.     (if (not (symbol? exp))
  517.     exp
  518.     (let ((denotation (mw:syntax-lookup env exp)))
  519.       (case (mw:denote-class denotation)
  520.         ((special macro identifier) (mw:identifier-name denotation))
  521.         (else (mw:bug "Bug detected by mw:atom" exp env))))
  522.   ) )
  523.  
  524.   (define (quasi subexp level)
  525.      (cond
  526.     ((null? subexp) subexp)
  527.     ((not (pair? subexp))
  528.      (if (zero? level) (mw:atom subexp env) subexp) ; the work is here
  529.     )
  530.     (else
  531.       (let ( (keyword (mw:syntax-lookup env (car subexp))) )
  532.         (cond
  533.           ((eq? keyword mw:denote-of-unquote)
  534.            (cons 'unquote (quasi (cdr subexp) (- level 1)))
  535.           )
  536.           ((eq? keyword mw:denote-of-unquote-splicing)
  537.            (cons 'unquote-splicing (quasi (cdr subexp) (- level 1)))
  538.           )
  539.           ((eq? keyword mw:denote-of-quasiquote)
  540.            (cons 'quasiquote (quasi (cdr subexp) (+ level 1)))
  541.           )
  542.           (else (map (lambda (ex) (quasi ex level)) subexp)
  543.           )
  544.         )
  545.     ) ) ; end else, let
  546.      ) ; end cond 
  547.   )
  548.  
  549.   (quasi exp 0) ; need to unquote to level 0 to paint
  550. )
  551.  
  552. ;;                                      --- E O F ---
  553.